home *** CD-ROM | disk | FTP | other *** search
/ Delphi Magazine Collection 2001 / Delphi Magazine Collection 20001 (2001).iso / DISKS / Issue51 / SafeCall / ComServerImpl.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1999-08-20  |  2.2 KB  |  96 lines
  1. unit ComServerImpl;
  2.  
  3. interface
  4.  
  5. uses
  6.   Windows, ActiveX, Classes, ComObj, ComServer_TLB, StdVcl;
  7.  
  8. type
  9.   TErrorTrappingTest = class(TTypedComObject, IErrorTrappingTest)
  10.   protected
  11.     {Declare IErrorTrappingTest methods here}
  12.     procedure Error1; safecall;
  13.     procedure Error2; safecall;
  14.     procedure Error3; safecall;
  15.     procedure Error4; safecall;
  16.     procedure Error5; safecall;
  17.   public
  18.     procedure Initialize; override;
  19.   end;
  20.  
  21. implementation
  22.  
  23. uses
  24.   ComServ, SysUtils, Forms;
  25.  
  26. type
  27.   TErrorLogger = class(TInterfacedObject, IServerExceptionHandler)
  28.   protected
  29.     procedure OnException(
  30.       const ServerClass, ExceptionClass, ErrorMessage: WideString;
  31.       ExceptAddr: Integer; const ErrorIID, ProgID: WideString;
  32.       var Handled: Integer; var Result: HResult);
  33.   end;
  34.  
  35. procedure TErrorTrappingTest.Error1;
  36. begin
  37.   StrToInt('Hello world')
  38. end;
  39.  
  40. procedure TErrorTrappingTest.Error2;
  41. begin
  42.   (TObject(Application.MainForm) as TScreen).Destroy
  43. end;
  44.  
  45. procedure TErrorTrappingTest.Error3;
  46. begin
  47.   Application.MainForm.ShowModal
  48. end;
  49.  
  50. procedure TErrorTrappingTest.Error4;
  51. begin
  52.   with Application.MainForm do
  53.     Tag := 5 div Tag
  54. end;
  55.  
  56. procedure TErrorTrappingTest.Error5;
  57. begin
  58.   IntToStr(PInteger(nil)^)
  59. end;
  60.  
  61. procedure TErrorTrappingTest.Initialize;
  62. begin
  63.   inherited;
  64.   ServerExceptionHandler := TErrorLogger.Create
  65. end;
  66.  
  67. { TErrorLogger }
  68.  
  69. procedure TErrorLogger.OnException(const ServerClass, ExceptionClass,
  70.   ErrorMessage: WideString; ExceptAddr: Integer; const ErrorIID,
  71.   ProgID: WideString; var Handled: Integer; var Result: HResult);
  72. var
  73.   Log: TextFile;
  74. const
  75.   LogName = 'C:\DelphiLog.Txt';
  76. begin
  77.   AssignFile(Log, LogName);
  78.   if FileExists(LogName) then
  79.     Append(Log)
  80.   else
  81.     Rewrite(Log);
  82.   try
  83.     WriteLn(Log, Format('Class %s (ProgId: %s) raised an %s exception at $%x: %s',
  84.       [ServerClass, ProgID, ExceptionClass, ExceptAddr, ErrorMessage]))
  85.   finally
  86.     CloseFile(Log)
  87.   end;
  88.   //Could kill off the exception like this, but not in this case
  89.   //Handled := Integer(True)
  90. end;
  91.  
  92. initialization
  93.   TTypedComObjectFactory.Create(ComServer, TErrorTrappingTest, Class_ErrorTrappingTest,
  94.     ciMultiInstance, tmApartment);
  95. end.
  96.